home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / perl5 / perl5.002 / lib / extutils / install.pm < prev    next >
Encoding:
Perl POD Document  |  1996-02-12  |  5.6 KB  |  200 lines
  1. package ExtUtils::Install;
  2.  
  3. require Exporter;
  4. @ISA = ('Exporter');
  5. @EXPORT = ('install','uninstall');
  6.  
  7. use Carp;
  8. use Cwd qw(cwd);
  9. use ExtUtils::MakeMaker; # to implement a MY class
  10. use File::Basename qw(dirname);
  11. use File::Copy qw(copy);
  12. use File::Find qw(find);
  13. use File::Path qw(mkpath);
  14. #use strict;
  15.  
  16. sub install {
  17.     my($hash,$verbose,$nonono) = @_;
  18.     $verbose ||= 0;
  19.     $nonono  ||= 0;
  20.     my(%hash) = %$hash;
  21.     my(%pack, %write,$dir);
  22.     local(*DIR, *P);
  23.     for (qw/read write/) {
  24.     $pack{$_}=$hash{$_};
  25.     delete $hash{$_};
  26.     }
  27.     my($blibdir);
  28.     foreach $blibdir (sort keys %hash) {
  29.     #Check if there are files, and if yes, look if the corresponding
  30.     #target directory is writable for us
  31.     opendir DIR, $blibdir or next;
  32.     while ($_ = readdir DIR) {
  33.         next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  34.         if (-w $hash{$blibdir} || mkpath($hash{$blibdir})) {
  35.         last;
  36.         } else {
  37.         croak("You do not have permissions to install into $hash{$blibdir}");
  38.         }
  39.     }
  40.     closedir DIR;
  41.     }
  42.     if (-f $pack{"read"}) {
  43.     open P, $pack{"read"} or die "Couldn't read $pack{'read'}";
  44.     # Remember what you found
  45.     while (<P>) {
  46.         chomp;
  47.         $write{$_}++;
  48.     }
  49.     close P;
  50.     }
  51.     my $cwd = cwd();
  52.     my $umask = umask 0;
  53.  
  54.     # This silly reference is just here to be able to call MY->catdir
  55.     # without a warning (Waiting for a proper path/directory module,
  56.     # Charles!) The catdir and catfile calls leave us with a lot of
  57.     # paths containing ././, but I don't want to use regexes on paths
  58.     # anymore to delete them :-)
  59.     my $MY = {};
  60.     bless $MY, 'MY';
  61.     my($source);
  62.     MOD_INSTALL: foreach $source (sort keys %hash) {
  63.     #copy the tree to the target directory without altering
  64.     #timestamp and permission and remember for the .packlist
  65.     #file. The packlist file contains the absolute paths of the
  66.     #install locations. AFS users may call this a bug. We'll have
  67.     #to reconsider how to add the means to satisfy AFS users also.
  68.     chdir($source) or next;
  69.     find(sub {
  70.         my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  71.                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
  72.         return unless -f _;
  73.         return if $_ eq ".exists";
  74.         my $targetdir = $MY->catdir($hash{$source},$File::Find::dir);
  75.         my $targetfile = $MY->catfile($targetdir,$_);
  76.         my $diff = 0;
  77.  
  78.         if ( -f $targetfile && -s _ == $size) {
  79.         # We have a good chance, we can skip this one
  80.         local(*F,*T);
  81.         open F, $_ or croak("Couldn't open $_: $!");
  82.         open T, $targetfile or croak("Couldn't open $targetfile: $!");
  83.         my($fr, $tr, $fbuf,$tbuf,$size);
  84.         $size = 1024;
  85.         # print "Reading $_\n";
  86.         while ( $fr = read(F,$fbuf,$size)) {
  87.             unless (
  88.                 $tr = read(T,$tbuf,$size) and 
  89.                 $tbuf eq $fbuf
  90.                ){
  91.             # print "diff ";
  92.             $diff++;
  93.             last;
  94.             }
  95.             # print "$fr/$tr ";
  96.         }
  97.         # print "\n";
  98.         close F;
  99.         close T;
  100.         } else {
  101.         print "$_ differs\n" if $verbose>1;
  102.         $diff++;
  103.         }
  104.  
  105.         if ($diff){
  106.         mkpath($targetdir,0,0755) unless $nonono;
  107.         print "mkpath($targetdir,0,0755)\n" if $verbose>1;
  108.         unlink $targetfile if -f $targetfile;
  109.         copy($_,$targetfile) unless $nonono;
  110.         print "Installing $targetfile\n" if $verbose;
  111.         utime($atime,$mtime,$targetfile) unless $nonono>1;
  112.         print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
  113.         chmod $mode, $targetfile;
  114.         print "chmod($mode, $targetfile)\n" if $verbose>1;
  115.         } else {
  116.         print "Skipping $targetfile (unchanged)\n";
  117.         }
  118.  
  119.         $write{$targetfile}++;
  120.  
  121.     }, ".");
  122.     chdir($cwd) or croak("Couldn't chdir....");
  123.     }
  124.     umask $umask;
  125.     if ($pack{'write'}) {
  126.     $dir = dirname($pack{'write'});
  127.     mkpath($dir,0,0755);
  128.     print "Writing $pack{'write'}\n";
  129.     open P, ">$pack{'write'}" or croak("Couldn't write $pack{'write'}: $!");
  130.     for (sort keys %write) {
  131.         print P "$_\n";
  132.     }
  133.     close P;
  134.     }
  135. }
  136.  
  137. sub uninstall {
  138.     my($fil,$verbose,$nonono) = @_;
  139.     die "no packlist file found: $fil" unless -f $fil;
  140.     local *P;
  141.     open P, $fil or croak("uninstall: Could not read packlist file $fil: $!");
  142.     while (<P>) {
  143.     chomp;
  144.     print "unlink $_\n" if $verbose;
  145.     unlink($_) || carp("Couldn't unlink $_") unless $nonono;
  146.     }
  147.     print "unlink $fil\n" if $verbose;
  148.     unlink($fil) || carp("Couldn't unlink $fil") unless $nonono;
  149. }
  150.  
  151. 1;
  152.  
  153. __END__
  154.  
  155. =head1 NAME
  156.  
  157. ExtUtils::Install - install files from here to there
  158.  
  159. =head1 SYNOPSIS
  160.  
  161. B<use ExtUtils::Install;>
  162.  
  163. B<install($hashref,$verbose,$nonono);>
  164.  
  165. B<uninstall($packlistfile,$verbose,$nonono);>
  166.  
  167. =head1 DESCRIPTION
  168.  
  169. Both functions, install() and uninstall() are specific to the way
  170. ExtUtils::MakeMaker handles the installation and deinstallation of
  171. perl modules. They are not designed as general purpose tools.
  172.  
  173. install() takes three arguments. A reference to a hash, a verbose
  174. switch and a don't-really-do-it switch. The hash ref contains a
  175. mapping of directories: each key/value pair is a combination of
  176. directories to be copied. Key is a directory to copy from, value is a
  177. directory to copy to. The whole tree below the "from" directory will
  178. be copied preserving timestamps and permissions.
  179.  
  180. There are two keys with a special meaning in the hash: "read" and
  181. "write". After the copying is done, install will write the list of
  182. target files to the file named by $hashref->{write}. If there is
  183. another file named by $hashref->{read}, the contents of this file will
  184. be merged into the written file. The read and the written file may be
  185. identical, but on AFS it is quite likely, people are installing to a
  186. different directory than the one where the files later appear.
  187.  
  188. uninstall() takes as first argument a file containing filenames to be
  189. unlinked. The second argument is a verbose switch, the third is a
  190. no-don't-really-do-it-now switch.
  191.  
  192. =cut
  193.  
  194. #=head1 NOTES
  195.  
  196. #=head1 BUGS
  197.  
  198. #=head1 AUTHORS
  199.  
  200.